home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlread.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  19.3 KB  |  905 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlread.c
  5. * RCS:          $Header: xlread.c,v 1.5 91/03/24 22:25:24 mayer Exp $
  6. * Description:  xlisp expression input routine
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:09:40 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlread.c,v 1.5 91/03/24 22:25:24 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46.  
  47. /* symbol parser modes */
  48. #define DONE    0
  49. #define NORMAL    1
  50. #define ESCAPE    2
  51.  
  52. /* external variables */
  53. extern LVAL s_stdout,true,s_dot;
  54. extern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
  55. extern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
  56. extern LVAL k_sescape,k_mescape;
  57. extern char buf[];
  58.  
  59. /* external routines */
  60. extern FILE *osaopen();
  61. extern double atof();
  62. extern ITYPE;
  63.  
  64. #define WSPACE "\t \f\r\n"
  65. #define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
  66. #define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
  67.  
  68. /* forward declarations */
  69. LOCAL FORWARD LVAL callmacro();    /* NPM: changed this to LOCAL */
  70. LOCAL FORWARD LVAL psymbol(),punintern(); /* NPM: changed this to LOCAL */
  71. LOCAL FORWARD LVAL pnumber(),pquote(),plist(),pvector(),pstruct(); /* NPM: changed this to LOCAL */
  72. LOCAL FORWARD LVAL readlist();    /* NPM: changed this to LOCAL */
  73. FORWARD LVAL tentry();
  74.  
  75. /* xlload - load a file of xlisp expressions */
  76. int xlload(fname,vflag,pflag)
  77.   char *fname; int vflag,pflag;
  78. {
  79.     char fullname[STRMAX+1];
  80.     LVAL fptr,expr;
  81.     CONTEXT cntxt;
  82.     FILE *fp;
  83.     int sts;
  84.  
  85.     /* protect some pointers */
  86.     xlstkcheck(2);
  87.     xlsave(fptr);
  88.     xlsave(expr);
  89.  
  90.     /* default the extension */
  91.     if (needsextension(fname)) {
  92.     strcpy(fullname,fname);
  93.     strcat(fullname,".lsp");
  94.     fname = fullname;
  95.     }
  96.  
  97.     /* allocate a file node */
  98.     fptr = cvfile(NULL);
  99.  
  100.     /* open the file */
  101.     if ((fp = osaopen(fname,"r")) == NULL) {
  102.     xlpopn(2);
  103.     return (FALSE);
  104.     }
  105.     setfile(fptr,fp);
  106.  
  107.     /* print the information line */
  108.     if (vflag)
  109.     { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
  110.  
  111.     /* read, evaluate and possibly print each expression in the file */
  112.     xlbegin(&cntxt,CF_ERROR,true);
  113.     if (setjmp(cntxt.c_jmpbuf))
  114.     sts = FALSE;
  115.     else {
  116.     while (xlread(fptr,&expr,FALSE)) {
  117.         expr = xleval(expr);
  118.         if (pflag)
  119.         stdprint(expr);
  120.     }
  121.     sts = TRUE;
  122.     }
  123.     xlend(&cntxt);
  124.  
  125.     /* close the file */
  126.     osclose(getfile(fptr));
  127.     setfile(fptr,NULL);
  128.  
  129.     /* restore the stack */
  130.     xlpopn(2);
  131.  
  132.     /* return status */
  133.     return (sts);
  134. }
  135.  
  136. /* xlread - read an xlisp expression */
  137. int xlread(fptr,pval,rflag)
  138.   LVAL fptr,*pval; int rflag;
  139. {
  140.     int sts;
  141.  
  142.     /* read an expression */
  143.     while ((sts = readone(fptr,pval)) == FALSE)
  144.     ;
  145.  
  146.     /* return status */
  147.     return (sts == EOF ? FALSE : TRUE);
  148. }
  149.  
  150. /* readone - attempt to read a single expression */
  151. int readone(fptr,pval)
  152.   LVAL fptr,*pval;
  153. {
  154.     LVAL val,type;
  155.     int ch;
  156.  
  157.     /* get a character and check for EOF */
  158.     if ((ch = xlgetc(fptr)) == EOF)
  159.     return (EOF);
  160.  
  161.     /* handle white space */
  162.     if ((type = tentry(ch)) == k_wspace)
  163.     return (FALSE);
  164.  
  165.     /* handle symbol constituents */
  166.     else if (type == k_const) {
  167.     xlungetc(fptr,ch);
  168.     *pval = psymbol(fptr);
  169.     return (TRUE);        
  170.     }
  171.  
  172.     /* handle single and multiple escapes */
  173.     else if (type == k_sescape || type == k_mescape) {
  174.     xlungetc(fptr,ch);
  175.     *pval = psymbol(fptr);
  176.     return (TRUE);
  177.     }
  178.     
  179.     /* handle read macros */
  180.     else if (consp(type)) {
  181.     if ((val = callmacro(fptr,ch)) && consp(val)) {
  182.         *pval = car(val);
  183.         return (TRUE);
  184.     }
  185.     else
  186.         return (FALSE);
  187.     }
  188.  
  189.     /* handle illegal characters */
  190.     else
  191.     xlerror("illegal character",cvfixnum((FIXTYPE)ch));
  192. }
  193.  
  194. /* rmhash - read macro for '#' */
  195. LVAL rmhash()
  196. {
  197.     LVAL fptr,mch,val;
  198.     int escflag,ch;
  199.  
  200.     /* protect some pointers */
  201.     xlsave1(val);
  202.  
  203.     /* get the file and macro character */
  204.     fptr = xlgetfile();
  205.     mch = xlgachar();
  206.     xllastarg();
  207.  
  208.     /* make the return value */
  209.     val = consa(NIL);
  210.  
  211.     /* check the next character */
  212.     switch (ch = xlgetc(fptr)) {
  213.     case '\'':
  214.         rplaca(val,pquote(fptr,s_function));
  215.         break;
  216.     case '(':
  217.         xlungetc(fptr,ch);
  218.         rplaca(val,pvector(fptr));
  219.         break;
  220.     case 'b':
  221.     case 'B':
  222.         rplaca(val,pnumber(fptr,2));
  223.         break;
  224.     case 'o':
  225.     case 'O':
  226.         rplaca(val,pnumber(fptr,8));
  227.         break;
  228.     case 'x':
  229.     case 'X':
  230.             rplaca(val,pnumber(fptr,16));
  231.         break;
  232.     case 's':
  233.     case 'S':
  234.         rplaca(val,pstruct(fptr));
  235.         break;
  236.     case '\\':
  237.         xlungetc(fptr,ch);
  238.         pname(fptr,&escflag);
  239.         ch = buf[0];
  240.         if (strlen(buf) > 1) {
  241.             upcase(buf);
  242.             if (strcmp(buf,"NEWLINE") == 0)
  243.             ch = '\n';
  244.             else if (strcmp(buf,"SPACE") == 0)
  245.             ch = ' ';
  246.             else
  247.             xlerror("unknown character name",cvstring(buf));
  248.         }
  249.         rplaca(val,cvchar(ch));
  250.         break;
  251.     case ':':
  252.             rplaca(val,punintern(fptr));
  253.         break;
  254.     case '|':
  255.             pcomment(fptr);
  256.         val = NIL;
  257.         break;
  258.     default:
  259.         xlerror("illegal character after #",cvfixnum((FIXTYPE)ch));
  260.     }
  261.  
  262.     /* restore the stack */
  263.     xlpop();
  264.  
  265.     /* return the value */
  266.     return (val);
  267. }
  268.  
  269. /* rmquote - read macro for '\'' */
  270. LVAL rmquote()
  271. {
  272.     LVAL fptr,mch;
  273.  
  274.     /* get the file and macro character */
  275.     fptr = xlgetfile();
  276.     mch = xlgachar();
  277.     xllastarg();
  278.  
  279.     /* parse the quoted expression */
  280.     return (consa(pquote(fptr,s_quote)));
  281. }
  282.  
  283. /* rmdquote - read macro for '"' */
  284. LVAL rmdquote()
  285. {
  286.     unsigned char buf[STRMAX+1],*p,*sptr;
  287.     LVAL fptr,str,newstr,mch;
  288.     int len,blen,ch,d2,d3;
  289.  
  290.     /* protect some pointers */
  291.     xlsave1(str);
  292.  
  293.     /* get the file and macro character */
  294.     fptr = xlgetfile();
  295.     mch = xlgachar();
  296.     xllastarg();
  297.  
  298.     /* loop looking for a closing quote */
  299.     len = blen = 0; p = buf;
  300.     while ((ch = checkeof(fptr)) != '"') {
  301.  
  302.     /* handle escaped characters */
  303.     switch (ch) {
  304.     case '\\':
  305.         switch (ch = checkeof(fptr)) {
  306.         case 't':
  307.             ch = '\011';
  308.             break;
  309.         case 'n':
  310.             ch = '\012';
  311.             break;
  312.         case 'f':
  313.             ch = '\014';
  314.             break;
  315.         case 'r':
  316.             ch = '\015';
  317.             break;
  318.         default:
  319.             if (ch >= '0' && ch <= '7') {
  320.                 d2 = checkeof(fptr);
  321.                 d3 = checkeof(fptr);
  322.                 if (d2 < '0' || d2 > '7'
  323.                  || d3 < '0' || d3 > '7')
  324.                 xlfail("invalid octal digit");
  325.                 ch -= '0'; d2 -= '0'; d3 -= '0';
  326.                 ch = (ch << 6) | (d2 << 3) | d3;
  327.             }
  328.             break;
  329.         }
  330.     }
  331.  
  332.     /* check for buffer overflow */
  333.     if (blen >= STRMAX) {
  334.          newstr = newstring(len + STRMAX + 1);
  335.         sptr = getstring(newstr); *sptr = '\0';
  336.         if (str) strcat(sptr,getstring(str));
  337.         *p = '\0'; strcat(sptr,buf);
  338.         p = buf; blen = 0;
  339.         len += STRMAX;
  340.         str = newstr;
  341.     }
  342.  
  343.     /* store the character */
  344.     *p++ = ch; ++blen;
  345.     }
  346.  
  347.     /* append the last substring */
  348.     if (str == NIL || blen) {
  349.     newstr = newstring(len + blen + 1);
  350.     sptr = getstring(newstr); *sptr = '\0';
  351.     if (str) strcat(sptr,getstring(str));
  352.     *p = '\0'; strcat(sptr,buf);
  353.     str = newstr;
  354.     }
  355.  
  356.     /* restore the stack */
  357.     xlpop();
  358.  
  359.     /* return the new string */
  360.     return (consa(str));
  361. }
  362.  
  363. /* rmbquote - read macro for '`' */
  364. LVAL rmbquote()
  365. {
  366.     LVAL fptr,mch;
  367.  
  368.     /* get the file and macro character */
  369.     fptr = xlgetfile();
  370.     mch = xlgachar();
  371.     xllastarg();
  372.  
  373.     /* parse the quoted expression */
  374.     return (consa(pquote(fptr,s_bquote)));
  375. }
  376.  
  377. /* rmcomma - read macro for ',' */
  378. LVAL rmcomma()
  379. {
  380.     LVAL fptr,mch,sym;
  381.     int ch;
  382.  
  383.     /* get the file and macro character */
  384.     fptr = xlgetfile();
  385.     mch = xlgachar();
  386.     xllastarg();
  387.  
  388.     /* check the next character */
  389.     if ((ch = xlgetc(fptr)) == '@')
  390.     sym = s_comat;
  391.     else {
  392.     xlungetc(fptr,ch);
  393.     sym = s_comma;
  394.     }
  395.  
  396.     /* make the return value */
  397.     return (consa(pquote(fptr,sym)));
  398. }
  399.  
  400. /* rmlpar - read macro for '(' */
  401. LVAL rmlpar()
  402. {
  403.     LVAL fptr,mch;
  404.  
  405.     /* get the file and macro character */
  406.     fptr = xlgetfile();
  407.     mch = xlgachar();
  408.     xllastarg();
  409.  
  410.     /* make the return value */
  411.     return (consa(plist(fptr)));
  412. }
  413.  
  414. /* rmrpar - read macro for ')' */
  415. LVAL rmrpar()
  416. {
  417.     xlfail("misplaced right paren");
  418. }
  419.  
  420. /* rmsemi - read macro for ';' */
  421. LVAL rmsemi()
  422. {
  423.     LVAL fptr,mch;
  424.     int ch;
  425.  
  426.     /* get the file and macro character */
  427.     fptr = xlgetfile();
  428.     mch = xlgachar();
  429.     xllastarg();
  430.  
  431.     /* skip to end of line */
  432.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
  433.     ;
  434.  
  435.     /* return nil (nothing read) */
  436.     return (NIL);
  437. }
  438.  
  439. /* pcomment - parse a comment delimited by #| and |# */
  440. LOCAL pcomment(fptr)
  441.   LVAL fptr;
  442. {
  443.     int lastch,ch,n;
  444.  
  445.     /* look for the matching delimiter (and handle nesting) */
  446.     for (n = 1, lastch = -1; n > 0 && (ch = xlgetc(fptr)) != EOF; ) {
  447.     if (lastch == '|' && ch == '#')
  448.         { --n; ch = -1; }
  449.     else if (lastch == '#' && ch == '|')
  450.         { ++n; ch = -1; }
  451.     lastch = ch;
  452.     }
  453. }
  454.  
  455. /* pnumber - parse a number */
  456. LOCAL LVAL pnumber(fptr,radix)
  457.   LVAL fptr; int radix;
  458. {
  459.     int digit,ch;
  460.     long num;
  461.     
  462.     for (num = 0L; (ch = xlgetc(fptr)) != EOF; ) {
  463.     if (islower(ch)) ch = toupper(ch);
  464.     if (!('0' <= ch && ch <= '9') && !('A' <= ch && ch <= 'F'))
  465.         break;
  466.     if ((digit = (ch <= '9' ? ch - '0' : ch - 'A' + 10)) >= radix)
  467.         break;
  468.     num = num * (long)radix + (long)digit;
  469.     }
  470.     xlungetc(fptr,ch);
  471.     return (cvfixnum((FIXTYPE)num));
  472. }
  473.  
  474. /* plist - parse a list */
  475. LOCAL LVAL plist(fptr)
  476.   LVAL fptr;
  477. {
  478.     LVAL val,expr,lastnptr,nptr;
  479.  
  480.     /* protect some pointers */
  481.     xlstkcheck(2);
  482.     xlsave(val);
  483.     xlsave(expr);
  484.  
  485.     /* keep appending nodes until a closing paren is found */
  486.     for (lastnptr = NIL; nextch(fptr) != ')'; )
  487.  
  488.     /* get the next expression */
  489.     switch (readone(fptr,&expr)) {
  490.     case EOF:
  491.         badeof(fptr);
  492.     case TRUE:
  493.  
  494.         /* check for a dotted tail */
  495.         if (expr == s_dot) {
  496.  
  497.         /* make sure there's a node */
  498.         if (lastnptr == NIL)
  499.             xlfail("invalid dotted pair");
  500.  
  501.         /* parse the expression after the dot */
  502.         if (!xlread(fptr,&expr,TRUE))
  503.             badeof(fptr);
  504.         rplacd(lastnptr,expr);
  505.  
  506.         /* make sure its followed by a close paren */
  507.         if (nextch(fptr) != ')')
  508.             xlfail("invalid dotted pair");
  509.         }
  510.  
  511.         /* otherwise, handle a normal list element */
  512.         else {
  513.         nptr = consa(expr);
  514.         if (lastnptr == NIL)
  515.             val = nptr;
  516.         else
  517.             rplacd(lastnptr,nptr);
  518.         lastnptr = nptr;
  519.         }
  520.         break;
  521.     }
  522.  
  523.     /* skip the closing paren */
  524.     xlgetc(fptr);
  525.  
  526.     /* restore the stack */
  527.     xlpopn(2);
  528.  
  529.     /* return successfully */
  530.     return (val);
  531. }
  532.  
  533. /* pvector - parse a vector */
  534. LOCAL LVAL pvector(fptr)
  535.   LVAL fptr;
  536. {
  537.     LVAL list,val;
  538.     int len,i;
  539.  
  540.     /* protect some pointers */
  541.     xlsave1(list);
  542.  
  543.     /* read the list */
  544.     list = readlist(fptr,&len);
  545.  
  546.     /* make a vector of the appropriate length */
  547.     val = newvector(len);
  548.  
  549.     /* copy the list into the vector */
  550.     for (i = 0; i < len; ++i, list = cdr(list))
  551.     setelement(val,i,car(list));
  552.  
  553.     /* restore the stack */
  554.     xlpop();
  555.  
  556.     /* return successfully */
  557.     return (val);
  558. }
  559.  
  560. /* pstruct - parse a structure */
  561. LOCAL LVAL pstruct(fptr)
  562.   LVAL fptr;
  563. {
  564.     extern LVAL xlrdstruct();
  565.     LVAL list,val;
  566.     int len;
  567.  
  568.     /* protect some pointers */
  569.     xlsave1(list);
  570.  
  571.     /* read the list */
  572.     list = readlist(fptr,&len);
  573.  
  574.     /* make the structure */
  575.     val = xlrdstruct(list);
  576.  
  577.     /* restore the stack */
  578.     xlpop();
  579.  
  580.     /* return successfully */
  581.     return (val);
  582. }
  583.  
  584. /* pquote - parse a quoted expression */
  585. LOCAL LVAL pquote(fptr,sym)
  586.   LVAL fptr,sym;
  587. {
  588.     LVAL val,p;
  589.  
  590.     /* protect some pointers */
  591.     xlsave1(val);
  592.  
  593.     /* allocate two nodes */
  594.     val = consa(sym);
  595.     rplacd(val,consa(NIL));
  596.  
  597.     /* initialize the second to point to the quoted expression */
  598.     if (!xlread(fptr,&p,TRUE))
  599.     badeof(fptr);
  600.     rplaca(cdr(val),p);
  601.  
  602.     /* restore the stack */
  603.     xlpop();
  604.  
  605.     /* return the quoted expression */
  606.     return (val);
  607. }
  608.  
  609. /* psymbol - parse a symbol name */
  610. LOCAL LVAL psymbol(fptr)
  611.   LVAL fptr;
  612. {
  613.     int escflag;
  614.     LVAL val;
  615.     pname(fptr,&escflag);
  616.     return (escflag || !isnumber(buf,&val) ? xlenter(buf) : val);
  617. }
  618.  
  619. /* punintern - parse an uninterned symbol */
  620. LOCAL LVAL punintern(fptr)
  621.   LVAL fptr;
  622. {
  623.     int escflag;
  624.     pname(fptr,&escflag);
  625.     return (xlmakesym(buf));
  626. }
  627.  
  628. /* pname - parse a symbol/package name */
  629. LOCAL int pname(fptr,pescflag)
  630.   LVAL fptr; int *pescflag;
  631. {
  632.     int mode,ch,i;
  633.     LVAL type;
  634.  
  635.     /* initialize */
  636.     *pescflag = FALSE;
  637.     mode = NORMAL;
  638.     i = 0;
  639.  
  640.     /* accumulate the symbol name */
  641.     while (mode != DONE) {
  642.  
  643.     /* handle normal mode */
  644.     while (mode == NORMAL)
  645.         if ((ch = xlgetc(fptr)) == EOF)
  646.         mode = DONE;
  647.         else if ((type = tentry(ch)) == k_sescape) {
  648.         i = storech(buf,i,checkeof(fptr));
  649.         *pescflag = TRUE;
  650.         }
  651.         else if (type == k_mescape) {
  652.         *pescflag = TRUE;
  653.         mode = ESCAPE;
  654.         }
  655.         else if (type == k_const
  656.          ||  (consp(type) && car(type) == k_nmacro))
  657.         i = storech(buf,i,islower(ch) ? toupper(ch) : ch);
  658.         else
  659.         mode = DONE;
  660.  
  661.     /* handle multiple escape mode */
  662.     while (mode == ESCAPE)
  663.         if ((ch = xlgetc(fptr)) == EOF)
  664.         badeof(fptr);
  665.         else if ((type = tentry(ch)) == k_sescape)
  666.         i = storech(buf,i,checkeof(fptr));
  667.         else if (type == k_mescape)
  668.         mode = NORMAL;
  669.         else
  670.         i = storech(buf,i,ch);
  671.     }
  672.     buf[i] = 0;
  673.  
  674.     /* check for a zero length name */
  675.     if (i == 0)
  676.     xlerror("zero length name");
  677.  
  678.     /* unget the last character and return it */
  679.     xlungetc(fptr,ch);
  680.     return (ch);
  681. }
  682.  
  683. /* readlist - read a list terminated by a ')' */
  684. LOCAL LVAL readlist(fptr,plen)
  685.   LVAL fptr; int *plen;
  686. {
  687.     LVAL list,expr,lastnptr,nptr;
  688.     int ch;
  689.  
  690.     /* protect some pointers */
  691.     xlstkcheck(2);
  692.     xlsave(list);
  693.     xlsave(expr);
  694.  
  695.     /* get the open paren */
  696.     if ((ch = nextch(fptr)) != '(')
  697.     xlfail("expecting an open paren");
  698.     xlgetc(fptr);
  699.  
  700.     /* keep appending nodes until a closing paren is found */
  701.     for (lastnptr = NIL, *plen = 0; (ch = nextch(fptr)) != ')'; ) {
  702.  
  703.     /* check for end of file */
  704.     if (ch == EOF)
  705.         badeof(fptr);
  706.  
  707.     /* get the next expression */
  708.     switch (readone(fptr,&expr)) {
  709.     case EOF:
  710.         badeof(fptr);
  711.     case TRUE:
  712.         nptr = consa(expr);
  713.         if (lastnptr == NIL)
  714.         list = nptr;
  715.         else
  716.         rplacd(lastnptr,nptr);
  717.         lastnptr = nptr;
  718.         ++(*plen);
  719.         break;
  720.     }
  721.     }
  722.  
  723.     /* skip the closing paren */
  724.     xlgetc(fptr);
  725.  
  726.     /* restore the stack */
  727.     xlpopn(2);
  728.  
  729.     /* return the list */
  730.     return (list);
  731. }
  732.  
  733. /* storech - store a character in the print name buffer */
  734. LOCAL int storech(buf,i,ch)
  735.   char *buf; int i,ch;
  736. {
  737.     if (i < STRMAX)
  738.     buf[i++] = ch;
  739.     return (i);
  740. }
  741.  
  742. /* tentry - get a readtable entry */
  743. LVAL tentry(ch)
  744.   int ch;
  745. {
  746.     LVAL rtable;
  747.     rtable = getvalue(s_rtable);
  748.     if (!vectorp(rtable) || ch < 0 || ch >= getsize(rtable))
  749.     return (NIL);
  750.     return (getelement(rtable,ch));
  751. }
  752.  
  753. /* nextch - look at the next non-blank character */
  754. LOCAL int nextch(fptr)
  755.   LVAL fptr;
  756. {
  757.     int ch;
  758.  
  759.     /* return and save the next non-blank character */
  760.     while ((ch = xlgetc(fptr)) != EOF && isspace(ch))
  761.     ;
  762.     xlungetc(fptr,ch);
  763.     return (ch);
  764. }
  765.  
  766. /* checkeof - get a character and check for end of file */
  767. LOCAL int checkeof(fptr)
  768.   LVAL fptr;
  769. {
  770.     int ch;
  771.  
  772.     if ((ch = xlgetc(fptr)) == EOF)
  773.     badeof(fptr);
  774.     return (ch);
  775. }
  776.  
  777. /* badeof - unexpected eof */
  778. LOCAL badeof(fptr)
  779.   LVAL fptr;
  780. {
  781.     xlgetc(fptr);
  782.     xlfail("unexpected EOF");
  783. }
  784.  
  785. /* isnumber - check if this string is a number */
  786. int isnumber(str,pval)
  787.   char *str; LVAL *pval;
  788. {
  789.     int dl,dr;
  790.     char *p;
  791.  
  792.     /* initialize */
  793.     p = str; dl = dr = 0;
  794.  
  795.     /* check for a sign */
  796.     if (*p == '+' || *p == '-')
  797.     p++;
  798.  
  799.     /* check for a string of digits */
  800.     while (isdigit(*p))
  801.     p++, dl++;
  802.  
  803.     /* check for a decimal point */
  804.     if (*p == '.') {
  805.     p++;
  806.     while (isdigit(*p))
  807.         p++, dr++;
  808.     }
  809.  
  810.     /* check for an exponent */
  811.     if ((dl || dr) && *p == 'E') {
  812.     p++;
  813.  
  814.     /* check for a sign */
  815.     if (*p == '+' || *p == '-')
  816.         p++;
  817.  
  818.     /* check for a string of digits */
  819.     while (isdigit(*p))
  820.         p++, dr++;
  821.     }
  822.  
  823.     /* make sure there was at least one digit and this is the end */
  824.     if ((dl == 0 && dr == 0) || *p)
  825.     return (FALSE);
  826.  
  827.     /* convert the string to an integer and return successfully */
  828.     if (pval) {
  829.     if (*str == '+') ++str;
  830.     if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
  831.     *pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
  832.     }
  833.     return (TRUE);
  834. }
  835.  
  836. /* defmacro - define a read macro */
  837. defmacro(ch,type,offset)
  838.   int ch; LVAL type; int offset;
  839. {
  840.     extern FUNDEF funtab[];
  841.     LVAL subr;
  842.     subr = cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset);
  843.     setelement(getvalue(s_rtable),ch,cons(type,subr));
  844. }
  845.  
  846. /* callmacro - call a read macro */
  847. LOCAL LVAL callmacro(fptr,ch)    /* NPM: changed this to LOCAL */
  848.   LVAL fptr; int ch;
  849. {
  850.     LVAL *newfp;
  851.  
  852.     /* create the new call frame */
  853.     newfp = xlsp;
  854.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  855.     pusharg(cdr(getelement(getvalue(s_rtable),ch)));
  856.     pusharg(cvfixnum((FIXTYPE)2));
  857.     pusharg(fptr);
  858.     pusharg(cvchar(ch));
  859.     xlfp = newfp;
  860.     return (xlapply(2));
  861. }
  862.  
  863. /* upcase - translate a string to upper case */
  864. LOCAL upcase(str)
  865.   unsigned char *str;
  866. {
  867.     for (; *str != '\0'; ++str)
  868.     if (islower(*str))
  869.         *str = toupper(*str);
  870. }
  871.  
  872. /* xlrinit - initialize the reader */
  873. xlrinit()
  874. {
  875.     LVAL rtable;
  876.     char *p;
  877.     int ch;
  878.  
  879.     /* create the read table */
  880.     rtable = newvector(256);
  881.     setvalue(s_rtable,rtable);
  882.  
  883.     /* initialize the readtable */
  884.     for (p = WSPACE; ch = *p++; )
  885.     setelement(rtable,ch,k_wspace);
  886.     for (p = CONST1; ch = *p++; )
  887.     setelement(rtable,ch,k_const);
  888.     for (p = CONST2; ch = *p++; )
  889.     setelement(rtable,ch,k_const);
  890.  
  891.     /* setup the escape characters */
  892.     setelement(rtable,'\\',k_sescape);
  893.     setelement(rtable,'|', k_mescape);
  894.  
  895.     /* install the read macros */
  896.     defmacro('#', k_nmacro,FT_RMHASH);
  897.     defmacro('\'',k_tmacro,FT_RMQUOTE);
  898.     defmacro('"', k_tmacro,FT_RMDQUOTE);
  899.     defmacro('`', k_tmacro,FT_RMBQUOTE);
  900.     defmacro(',', k_tmacro,FT_RMCOMMA);
  901.     defmacro('(', k_tmacro,FT_RMLPAR);
  902.     defmacro(')', k_tmacro,FT_RMRPAR);
  903.     defmacro(';', k_tmacro,FT_RMSEMI);
  904. }
  905.